home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
lsp
/
evalmacros.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-04
|
9KB
|
272 lines
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; evalmacros.lsp
(in-package 'lisp)
(export '(defvar defparameter defconstant))
(in-package 'system)
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
(eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))
(eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
(defmacro defvar (var &optional (form nil form-sp) doc-string)
(if form-sp
(if doc-string
`(progn (si:*make-special ',var)
(si:putprop ',var ,doc-string 'variable-documentation)
(unless (boundp ',var)
(setq ,var ,form))
',var)
`(progn (si:*make-special ',var)
(unless (boundp ',var)
(setq ,var ,form))
',var))
`(progn (si:*make-special ',var)
',var)))
(defmacro defparameter (var form &optional doc-string)
(if doc-string
`(progn (si:*make-special ',var)
(si:putprop ',var ,doc-string 'variable-documentation)
(setq ,var ,form)
',var)
`(progn (si:*make-special ',var)
(setq ,var ,form)
',var)))
(defmacro defconstant (var form &optional doc-string)
(if doc-string
`(progn (si:*make-constant ',var ,form)
(si:putprop ',var ,doc-string 'variable-documentation)
',var)
`(progn (si:*make-constant ',var ,form)
',var)))
;;; Each of the following macros is also defined as a special form.
;;; Thus their names need not be exported.
(defmacro and (&rest forms)
(if (endp forms)
t
(let ((x (reverse forms)))
(do ((forms (cdr x) (cdr forms))
(form (car x) `(if ,(car forms) ,form)))
((endp forms) form))))
)
(defmacro or (&rest forms)
(if (endp forms)
nil
(let ((x (reverse forms)))
(do ((forms (cdr x) (cdr forms))
(form (car x)
(let ((temp (gensym)))
`(let ((,temp ,(car forms)))
(if ,temp ,temp ,form)))))
((endp forms) form))))
)
(defmacro locally (&rest body) `(let () ,@body))
(defmacro loop (&rest body &aux (tag (gensym)))
`(block nil (tagbody ,tag (progn ,@body) (go ,tag))))
(defmacro defmacro (name vl &rest body)
`(si:define-macro ',name (si:defmacro* ',name ',vl ',body)))
(defmacro defun (name lambda-list &rest body)
(multiple-value-bind (doc decl body)
(find-doc body nil)
(if doc
`(progn (setf (get ',name 'si:function-documentation) ,doc)
(setf (symbol-function ',name)
#'(lambda ,lambda-list
,@decl (block ,name ,@body)))
',name)
`(progn (setf (symbol-function ',name)
#'(lambda ,lambda-list
,@decl (block ,name ,@body)))
',name))))
; assignment
(defmacro psetq (&rest args)
(do ((l args (cddr l))
(forms nil)
(bindings nil))
((endp l) (list* 'let* (reverse bindings) (reverse (cons nil forms))))
(declare (object l))
(let ((sym (gensym)))
(push (list sym (cadr l)) bindings)
(push (list 'setq (car l) sym) forms)))
)
; conditionals
(defmacro cond (&rest clauses &aux (form nil))
(dolist (l (reverse clauses) form)
(declare (object l))
(cond ((endp (cdr l))
(if (eq (car l) 't)
(setq form 't)
(let ((sym (gensym)))
(setq form `(let ((,sym ,(car l)))
(if ,sym ,sym ,form))))))
((eq (car l) 't)
(setq form (if (endp (cddr l))
(cadr l)
`(progn ,@(cdr l)))))
(t (setq form (if (endp (cddr l))
`(if ,(car l) ,(cadr l) ,form)
`(if ,(car l) (progn ,@(cdr l)) ,form))))))
)
(defmacro when (pred &rest body)
`(if ,pred (progn ,@body)))
(defmacro unless (pred &rest body)
`(if (not ,pred) (progn ,@body)))
; program feature
(defmacro prog (vl &rest body &aux (decl nil))
(do ()
((or (endp body)
(not (consp (car body)))
(not (eq (caar body) 'declare)))
`(block nil (let ,vl ,@decl (tagbody ,@body)))
)
(push (car body) decl)
(pop body))
)
(defmacro prog* (vl &rest body &aux (decl nil))
(do ()
((or (endp body)
(not (consp (car body)))
(not (eq (caar body) 'declare)))
`(block nil (let* ,vl ,@decl (tagbody ,@body)))
)
(push (car body) decl)
(pop body))
)
; sequencing
(defmacro prog1 (first &rest body &aux (sym (gensym)))
`(let ((,sym ,first)) ,@body ,sym))
(defmacro prog2 (first second &rest body &aux (sym (gensym)))
`(progn ,first (let ((,sym ,second)) ,@body ,sym)))
; multiple values
(defmacro multiple-value-list (form)
`(multiple-value-call 'list ,form))
(defmacro multiple-value-setq (vars form)
(do ((vl vars (cdr vl))
(sym (gensym))
(forms nil)
(n 0 (1+ n)))
((endp vl) `(let ((,sym (multiple-value-list ,form))) ,@forms))
(declare (fixnum n) (object vl))
(push `(setq ,(car vl) (nth ,n ,sym)) forms))
)
(defmacro multiple-value-bind (vars form &rest body)
(do ((vl vars (cdr vl))
(sym (gensym))
(bind nil)
(n 0 (1+ n)))
((endp vl) `(let* ((,sym (multiple-value-list ,form)) ,@(reverse bind))
,@body))
(declare (fixnum n) (object vl))
(push `(,(car vl) (nth ,n ,sym)) bind))
)
(defmacro do (control (test . result) &rest body
&aux (decl nil) (label (gensym)) (vl nil) (step nil))
(do ()
((or (endp body)
(not (consp (car body)))
(not (eq (caar body) 'declare))))
(push (car body) decl)
(pop body))
(dolist (c control)
(declare (object c))
(push (list (car c) (cadr c)) vl)
(unless (endp (cddr c))
(push (car c) step)
(push (caddr c) step)))
`(block nil
(let ,(reverse vl)
,@decl
(tagbody
,label (if ,test (return (progn ,@result)))
(tagbody ,@body)
(psetq ,@(reverse step))
(go ,label)))))
(defmacro do* (control (test . result) &rest body
&aux (decl nil) (label (gensym)) (vl nil) (step nil))
(do ()
((or (endp body)
(not (consp (car body)))
(not (eq (caar body) 'declare))))
(push (car body) decl)
(pop body))
(dolist (c control)
(declare (object c))
(push (list (car c) (cadr c)) vl)
(unless (endp (cddr c))
(push (car c) step)
(push (caddr c) step)))
`(block nil
(let* ,(reverse vl)
,@decl
(tagbody
,label (if ,test (return (progn ,@result)))
(tagbody ,@body)
(setq ,@(reverse step))
(go ,label))))
)
(defmacro case (keyform &rest clauses &aux (form nil) (key (gensym)))
(dolist (clause (reverse clauses) `(let ((,key ,keyform)) ,form))
(declare (object clause))
(cond ((or (eq (car clause) 't) (eq (car clause) 'otherwise))
(setq form `(progn ,@(cdr clause))))
((consp (car clause))
(setq form `(if (member ,key ',(car clause))
(progn ,@(cdr clause))
,form)))
((car clause)
(setq form `(if (eql ,key ',(car clause))
(progn ,@(cdr clause))
,form)))))
)
(defmacro return (&optional (val nil)) `(return-from nil ,val))
(defmacro dolist ((var form &optional (val nil)) &rest body
&aux (temp (gensym)))
`(do* ((,temp ,form (cdr ,temp)) (,var (car ,temp) (car ,temp)))
((endp ,temp) ,val)
,@body))
(defmacro dotimes ((var form &optional (val nil)) &rest body
&aux (temp (gensym)))
`(do* ((,temp ,form) (,var 0 (1+ ,var)))
((>= ,var ,temp) ,val)
,@body))